; ORIGINAL: 3dt2.1/examples/cmd.scm
; $Id: cmd.scm,v 1.5 1997/05/01 15:48:10 jread Exp $
;----------------------------------------------------------------------
; Purpose---
;    Provide simple command processing with defered evaluation of arguments
;
;----------------------------------------------------------------------

(provide 'cmd)

(require 'pick "pick.scm")

(define Command_Stack '())
(define Current_Command `())
(define Current_Argument 0)
(define Argument_Template '())
(define Argument_List '())
(define Argument_Sub_List '())
(define Number_Of_Args_Needed 0)
(define Current_Selection '())

;;======================================================================
;; unhighlight selected entities
(define Flash-Time 200)
(define flash (lambda (e)
                (entity:set-highlight e ON)
                (system:sleep Flash-Time)
                (entity:set-highlight e OFF)
                e))

(define (cmd:clear-selection)
  (if (not (null? Current_Selection))
      (begin
        (system:sleep Flash-Time)
        (let loop ((l Current_Selection))
          (cond
            ((null? l) (set! Current_Selection '()) l)
            ((entity? (car l)) (entity:set-highlight (car l) #f) (loop (cdr l)))
            ((entray? (car l))
             (entity:set-highlight (entray:entity (car l)) #f)
             (loop (cdr l)))
            )))))

(define arg:desc
  (lambda c
    (set! Number_Of_Args_Needed (+ Number_Of_Args_Needed 1))
    (let ((argvec (make-vector 4 #f))
          (tail c))
      (if (not (null? tail))
          (begin
            (vector-set! argvec 0 (car tail))
            (set! tail (cdr tail))
            (if (not (null? tail))
                (begin
                  (vector-set! argvec 1 (car tail))
                  (set! tail (cdr tail))
                  (if (not (null? tail))
                      (begin
                        (vector-set! argvec 2 (car tail))
                        (set! tail (cdr tail))
                        (if (not (null? tail))
                            (vector-set! argvec 3 (car tail))
                            )))))))
      (set! Argument_Template (append Argument_Template (list argvec)))
      )
    '(arg:next)))

(define cmd:push-command
  (lambda (rtn)
    (rbd:push)
    (set! Command_Stack
          (cons (vector rtn
                        Current_Command
                        Current_Argument
                        Argument_Template
                        Argument_List
                        Argument_Sub_List
                        Number_Of_Args_Needed
                        )
                Command_Stack)
          )))

(define cmd:pop-command
  (lambda (rtn-value)
    (rbd:pop)
    (if (not (null? Command_Stack))
        (let* ((cmd-vec (car Command_Stack))
               (rtn (vector-ref cmd-vec 0)))
          (set! Current_Command (vector-ref cmd-vec 1))
          (set! Current_Argument (vector-ref cmd-vec 2))
          (set! Argument_Template (vector-ref cmd-vec 3))
          (set! Argument_List (vector-ref cmd-vec 4))
          (set! Argument_Sub_List (vector-ref cmd-vec 5))
          (set! Number_Of_Args_Needed (vector-ref cmd-vec 6))
          (set! Command_Stack (cdr Command_Stack))
          (if rtn
              (arg:set rtn-value)
              (arg:prepare-next)
              rtn-value)
          )
        0)))

(define (cmd:init)
  (set! Current_Command #f)
  (set! Argument_Template '())
  (set! Argument_List '())
  (set! Argument_Sub_List '())
  (set! Number_Of_Args_Needed 0)
  (set! Current_Argument 0)
  (ui:prompt " ")
  (set! mouse-down-hook (lambda (m) (arg:set m)))
  (set! mouse-up-hook '())
  (cmd:clear-selection)
  )

(define (cmd:clear)
  (cmd:init)
  (rbd:clear)
  (set! Command_Stack '())
  (set! mouse-down-hook '())
  (set! mouse-up-hook '())
  )

(define (cmd:reset)
  (set! Argument_List '())
  (set! Current_Argument 0)
  (ui:prompt " ")
  (cmd:clear-selection)
  (arg:prepare-next)
  )

(define cmd:set-command
  (lambda (c)
    (set! Current_Command c)
    (if (> Number_Of_Args_Needed 0) (arg:prepare-next))))

(define cmd:set
  (macro (c)
    (cmd:init)
    (rbd:clear)
    (set! Command_Stack '())
    `(cmd:set-command ,c)))

(define cmd:push-void
  (macro (c)
    (cmd:push-command #f)
    (cmd:init)
    `(cmd:set-command ,c)))

(define cmd:push-ret
  (macro (c)
    (cmd:push-command #t)
    (cmd:init)
    `(cmd:set-command ,c)))

;; process simple style commands
(define (cmd proc . args)
  (cmd:init)
  (rbd:clear)
  (set! Command_Stack '())
  (set! Current_Command (list proc))
  ;; process arguments
  (if (not (null? args))
      (begin
        (for-each
          (lambda (arg)
            (set! Current_Command (cons
                                    (if (procedure? arg)
                                        (arg:desc arg)
                                        arg)
                                    Current_Command))
            )
          args)
        (set! Current_Command (reverse Current_Command))
        ))
  (if (> Number_Of_Args_Needed 0) (arg:prepare-next))
  )

;;======================================================================
(define arg:set
  (lambda (arg)

    ;; add code to check for a valid template first

    (let* ((argvec (list-ref Argument_Template Current_Argument))
           (cvt-proc (vector-ref argvec 0))
           (post-proc (vector-ref argvec 2))
           (list-proc (vector-ref argvec 3))
           (evaluated-arg arg)
           (result arg)
           )
      (if (procedure? cvt-proc)
          (set! evaluated-arg (cvt-proc arg)))
      (if (not (eq? evaluated-arg 'INVALID_ARGUMENT))
          (begin
            (if (procedure? post-proc)
                (post-proc evaluated-arg)
                (eval post-proc))
            (if list-proc
                (begin
                  (if evaluated-arg
                      (set! Argument_Sub_List (cons
                                                evaluated-arg
                                                Argument_Sub_List))

                      (set! evaluated-arg (reverse Argument_Sub_List))
                      (if (procedure? list-proc)
                          (set! evaluated-arg (list-proc evaluated-arg)))
                      (set! Current_Argument (+ Current_Argument 1))
                      (set! Argument_List (append
                                            Argument_List (list evaluated-arg)))
                      (set! Argument_Sub_List '())
                      )
                  )

                (set! Argument_List (append Argument_List (list evaluated-arg)))
                (set! Current_Argument (+ Current_Argument 1))
                )
            (if (= Current_Argument Number_Of_Args_Needed)
                (begin
                  (set! Current_Argument 0)
                  (cmd:clear-selection)
                  (set! result (eval Current_Command))
                  (set! Current_Argument 0)
                  (set! Argument_List '())
                  (if (not (null? Command_Stack))
                      (set! result (cmd:pop-command result))
                      (arg:prepare-next)
                      result)
                  )
                (set! result evaluated-arg)
                (arg:prepare-next))
            result)
          )
      evaluated-arg)
    ))

(define arg:prepare-next
  (lambda ()
    (if (< Current_Argument Number_Of_Args_Needed)
        (let* ((argvec (list-ref Argument_Template Current_Argument))
               (pre-proc (vector-ref argvec 1))
               )
          (if (procedure? pre-proc)
              (pre-proc Current_Argument)
              (eval pre-proc))
          ))))

(define arg:next
  (lambda ()
    (let ((arg (list-ref Argument_List Current_Argument)))
      (set! Current_Argument (+ 1 Current_Argument))
      arg)))

;;======================================================================
;; Procedures for converting pick-events into other arg types

(define position-from-mouse pick:position)
(define %point
  (lambda (arg)
    (if (position? arg)
        arg
        (if (event:left? arg)
            (let ((pt (position-from-mouse arg)))
              (if (position? pt)
                  pt
                  (begin
                    (system:bell)
                    'INVALID_ARGUMENT)
                  ))
            #f))))


(define (general-pick-cmd pick-proc test-proc)
  (lambda (evt)
    (if (event:left? evt)
        (let ((ent (pick-proc evt)))
          (if (test-proc ent)
              (begin
                (if (entity? ent) (entity:set-highlight ent ON))
                (if (entray? ent) (entity:set-highlight (entray:entity ent) ON))
                (set! Current_Selection (cons ent Current_Selection))
                )
              (begin
                (system:bell)
                (set! ent 'INVALID_ARGUMENT)
                )
              )
          ent)
        #f)))

(define (pick-first-face evt) (pick:face evt 1))

(define %pick (general-pick-cmd pick:entity entity?));
(define %pickr (general-pick-cmd pick:entity-with-ray entray?));
(define %edge (general-pick-cmd pick:edge entity?))
(define %edger (general-pick-cmd pick:edge-with-ray entray?))
(define %face (general-pick-cmd pick-first-face entity?))
(define %arg (lambda (a) a))

;;----------------------------------------------------------------------
;; These procedures can be used to select the position conversion method

(define (screen-pos)(set! position-from-mouse pick:position))
(define (curve-end)
  (set! position-from-mouse
        (lambda (evt)
          (let ((vp (pick:vertex-or-point evt)))
            (cond
              ((vertex? vp) (flash vp) (vertex:position vp))
              ((point? vp) (flash vp) (point:position vp))
              (else #f)
              )))))
(define (curve-mid)
  (set! position-from-mouse
        (lambda (evt)
          (let ((crv (pick:edge evt)))
            (cond
              ((edge:curve? crv) (flash crv) (curve:eval-pos crv .5))
              (else #f)
              )))))
(define (curve-close)
  (set! position-from-mouse
        (lambda (evt)
          (let ((eray (pick:edge-with-ray evt)))
            (cond
              ((and (entray? eray) (edge:curve? (entray:entity eray)))
               (flash (entray:entity eray))
               (car (curve:ray-pos eray)))
              (else #f)
              )))))

;;=====================================================================
;; Setup an error handler which will pop up an error dialog, and
;; reset the command processor

(define (error-string error-msg)
  (string-append
    (format #f "~s: " (car error-msg))
    (apply format `(#f ,@(cdr error-msg)))
    ))

(set! error-handler
      (lambda error-msg
        (cmd:reset)
        (system:bell)
        (ui:error-dialog (error-string error-msg))))
